; -*-Scheme-*-

;************************************************************************/
;*                                                                      */
;* Copyright (c) 2003-2009 Vladimir Tsichevski <tsichevski@gmail.com>   */
;*                                                                      */
;* This file is part of bigloo-lib (http://bigloo-lib.sourceforge.net)  */
;*                                                                      */
;* This library is free software; you can redistribute it and/or        */
;* modify it under the terms of the GNU Lesser General Public           */
;* License as published by the Free Software Foundation; either         */
;* version 2 of the License, or (at your option) any later version.     */
;*                                                                      */
;* This library is distributed in the hope that it will be useful,      */
;* but WITHOUT ANY WARRANTY; without even the implied warranty of       */
;* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU    */
;* Lesser General Public License for more details.                      */
;*                                                                      */
;* You should have received a copy of the GNU Lesser General Public     */
;* License along with this library; if not, write to the Free Software  */
;* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 */
;* USA                                                                  */
;*                                                                      */
;************************************************************************/

(module
 time
 (extern
;;  (include "config.h")
  (include "common.h")
  )
 (import os)
 (export
  (make-tm::tm)
  (gmtime::tm #!optional
              (seconds::elong (current-seconds))
              (tm::tm(make-tm)))

  (localtime::tm #!optional
                 (seconds::elong (current-seconds))
                 (tm::tm (make-tm)))

  (strftime::bstring tm::tm #!optional  (format::bstring "%x %X"))
  (current-milliseconds::elong)
  (ctime::bstring #!optional seconds)
  (mktime::tm year::int            ;; YYYY
	      month::int           ;; 1-12
	      day::int #!optional
              (hour::int 0)
              (minute::int 0)
              (second::int 0))

  (timezone::int)
  (tzname::bstring)
  (daylight::int)
  (read-date::tm fmt::bstring port::input-port)
  (utctime->tm::tm utc::bstring)
  (tm->utctime::bstring time::tm)
  (tm->seconds::elong ::tm)
  )
 )

(define-object (tm "struct tm*") ()
  (fields
   (int (sec tm_sec))
   (int (min tm_min))
   (int (hour tm_hour))
   (int (mday tm_mday))
   (int (mon tm_mon))
   (int (year tm_year))
   ))

(define (tm->seconds::elong tm::tm)
  (let((result::elong (pragma::long "mktime($1)" tm)))
    (if (< result 0)
	(cerror "tm->seconds")
	result)))

(define (timezone::int)
  (let((result::int (pragma::int "0")))
    (pragma "
#if HAVE_STRUCT_TM_TM_ZONE
struct tm tm;
unsigned long iseconds = 0;
localtime_r(&iseconds, &tm);
$1 = tm.tm_gmtoff;
#else
$1 = timezone;
#endif
" result)
    result))

(define (tzname::bstring)
  (let((result::string (pragma::string "NULL")))
    (pragma "
#if HAVE_STRUCT_TM_TM_ZONE
struct tm tm;
unsigned long iseconds = 0;
localtime_r(&iseconds, &tm);
$1 = tm.tm_zone;
#else
$1 = \"???\";
#endif
" result)
    result))
;   (values
;    (pragma::bstring "string_to_bstring_len(tzname[0], 3)")
;    (pragma::bstring "string_to_bstring_len(tzname[1], 3)")))

(define (daylight::int)
  (let((result::int (pragma::int "0")))
    (pragma "
struct tm tm;
unsigned long iseconds = 0;
localtime_r(&iseconds, &tm);
$1 = tm.tm_isdst" result)
    result))
;;  (pragma::int "daylight"))

;; return pointer to uninitialized (zero-filled) struct tm
(define (make-tm::tm)
  (pragma::tm "(struct tm*)GC_malloc_atomic(sizeof(struct tm))"))

(define (localtime::tm #!optional
                       (seconds::elong (current-seconds))
		       (tm::tm (make-tm)))
  (let()
    (pragma "unsigned long iseconds = $1" seconds)
    (pragma "localtime_r(&iseconds, $1)"tm)
    tm))

(define (gmtime::tm #!optional
                    (seconds::elong (current-seconds))
		    (tm::tm(make-tm)))
  (let()
    (pragma "unsigned long iseconds = $1" seconds)
    (pragma "gmtime_r(&iseconds, $1)"tm)
    tm))

(define(strftime::bstring tm::tm #!optional (format::bstring "%x %X"))
  (let()
    (pragma "char formatted_time[1024]")
    (pragma "strftime(formatted_time,
           sizeof(formatted_time),
           $1,
           $2)" ($bstring->string format) tm)
    (pragma::string "formatted_time")))

;; Note: trailing newline removed!
(define (ctime::bstring #!optional seconds)
  (let((seconds::elong (or seconds (current-seconds))))
    (let ()
      (pragma "unsigned long iseconds = $1"seconds)
      (pragma "char buffer[128];")
      (let((u-ctime
           (pragma::string "CTIME_R(&iseconds, buffer, sizeof(buffer))")))
        (substring u-ctime 0 (-fx(string-length u-ctime)1))))))

(define (current-milliseconds::elong)
  (pragma "struct timeval now; gettimeofday(&now, NULL)")
  (pragma::elong "(double)now.tv_sec + now.tv_usec / 1000"))

(define (mktime::tm year::int            ;; YYYY
		    month::int           ;; 1-12
		    day::int #!optional
		    (hour::int 0)
		    (minute::int 0)
		    (second::int 0))
  (let((tm(make-tm)))
    (pragma
     "
  $1->tm_sec = $2;
  $1->tm_min = $3;
  $1->tm_hour = $4;
  $1->tm_mday = $5;
  $1->tm_mon = $6 - 1;
  $1->tm_year = $7 - 1900;"
     tm second minute hour day month year)
    tm))

;*-------------------------------------------------------------------*;
;*  Formatted date reading                                           *;
;*-------------------------------------------------------------------*;
(define(read-date::tm fmt::bstring port::input-port)
  (define current-field::char #\space)

  (define(raise-exn . messages)
    (error "read-date"
	   (format "reading %~a spec"current-field)
	   (apply format messages)))

  (define(read-2-digits)
    (read/rp (regular-grammar
      ()
      ((: digit digit)(the-fixnum))
      (else (raise-exn "two digits required")))
     port))

  (define(read-3-digits)
    (read/rp (regular-grammar
      ()
      ((: digit digit digit)(the-fixnum))
      (else (raise-exn "3 digits required")))
     port))

  (define(read-4-digits)
    (read/rp (regular-grammar
      ()
      ((: digit digit digit digit)(the-fixnum))
      (else (raise-exn "3 digits required")))
     port))

  (define(check-interval::int reader::procedure minvalue::int maxvalue::int)
    (let((value::int(reader)))
      (when(or(<fx value minvalue)(>fx value maxvalue))
	   (raise-exn "value out of bounds: ~a (~a to ~a)"
		      value
		      minvalue
		      maxvalue))
      value))

  (define(expect-char c::char)
    (let((got(read-char port)))
      (unless(eq? got c)
	     (raise-exn "expected ~s got ~s" c got))))
  
  (define *month-names* #f)

  ;; read month names. Poor man's solution: doesn't respect locales
  ;; and anything.
  (define (read-month)
    (read/rp
     (regular-grammar
      ()
      ((or "yan" "Yan" "YAN")
       0)
      ((or "feb" "Feb" "FEB")
       1)
      ((or "mar" "Mar" "MAR")
       2)
      ((or "apr" "Apr" "APR")
       3)
      ((or "may" "May" "MAY")
       4)
      ((or "jun" "Jun" "JUN")
       5)
      ((or "jul" "Jul" "JUL")
       6)
      ((or "aug" "Aug" "AUG")
       7)
      ((or "sep" "Sep" "SEP")
       8)
      ((or "oct" "Oct" "OCT")
       9)
      ((or "nov" "Nov" "NOV")
       10)
      ((or "dec" "Dec" "DEC")
       11)
      (else (raise-exn "cannot deduce month no")))
     port))


  (let*((tm::tm (localtime(current-seconds)))
	(second #f)
	(set-second!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (unless second
		     (pragma "$1->tm_sec = $2"tm s)))
	   #unspecified))
	(minute #f)
	(set-minute!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (unless minute
		     (pragma "$1->tm_min = $2"tm s)))
	   (set-second! 0)))
	(hour #f)
	(set-hour!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (unless hour
		     (pragma "$1->tm_hour = $2"tm s)))
	   (set-minute! 0)))
	(day #f)
	(set-day!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (unless day
		     (pragma "$1->tm_mday = $2"tm s)))
	   (set-hour! 0)))
	(month #f)
	(set-month!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (unless month
		     (pragma "$1->tm_mon = $2"tm s)))
	   (set-day! 0)))
	
	(set-year!
	 (lambda(s::int)
	   (let((tm::tm tm))
	     (pragma "$1->tm_year = $2 - 1900"tm s))
	   (set-month! 0)))
	(fs(open-input-string fmt)))
    
    (let loop ((c(read-char fs)))
      (if (eof-object? c)
	 tm
	 (begin
	   (if(char=? c #\%)
	      (begin
		(set! current-field(read-char fs))
		(case current-field
		  ((#\S)
		   ;;The second as a decimal number.
		   (set-second!(check-interval read-2-digits 0 59))
		   (set! second #t))
		 
		  ((#\M)
		   ;;The minute as a decimal number (01 to 59).
		   (set-minute!(check-interval read-2-digits 0 59))
		   (set! minute #t))
		    
		  ((#\H)
		   ;;The hour as a decimal number using a 24-hour clock
		   ;;(range 00 to 23).
		   (set-hour!(check-interval read-2-digits 0 23))
		   (set! hour #t))

		  ((#\I)
		   ;;The  hour as a decimal number using a 12-hour clock
		   ;;(range 01 to 12).
		   (set-hour!(check-interval read-2-digits 0 12))
		   (set! hour #t))
		
		  ((#\d)
		   ;;The  day of the month as a decimal number (range 01 to 31)
		   (set-day!(check-interval read-2-digits 1 31))
		   (set! day #t))
				
		  ((#\m)
		   ;;The month as a decimal number (range 01 to 12).
		   (set-month!(-fx(check-interval read-2-digits 1 12)1))
		   (set! month #t))
		
		  ((#\b)
		   ;;The abbreviated month name according to the current locale.
		   (set-month! (read-month))
		   (set! month #t))
		
		  ((#\Y)
		   ;;The year as a decimal number including the century.
		   (set-year!(check-interval read-4-digits 1970 3000)))

		  ((#\y)
		   ;;The year as a decimal number without a century.
		   (set-year!(+fx 2000(read-2-digits))))

		  ((#\p)
		   ;;Either  'am'  or  'pm'  according to the given time
		   ;;value, or the corresponding strings for the current
		   ;;locale.
		   (read/rp
		    (regular-grammar
		     ()
		     ((: "am")
		      #unspecified)
		     ((: "pm")
		      (let((tm::tm tm))
			(pragma "if($1->tm_hour < 13)$1->tm_hour += 12"tm)
			#unspecified))
		     (else
		      (raise-exn "am/pm expected")))
		    port))
		  
		  ((#\%)
		   ;;A literal '%' character.
		   (expect-char #\%))
		  
		  (else
		   (raise-exn "not supported"))))
	      (expect-char c))
	   (loop(read-char fs)))))))
;;(read-date "%d.%m.%Y %H:%M"(open-input-string "05.12.1999 12:30"))

(define(utctime->tm::tm utc::bstring)
  (read-date "%Y%m%d%H%M%S"(open-input-string utc)))

(define(tm->utctime::bstring time::tm)
  (strftime time "%Y%m%d%H%M%SZ"))
